home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / bled.arc / UTILBLED.BAS < prev   
Encoding:
BASIC Source File  |  1986-04-13  |  17.5 KB  |  680 lines
  1. SUB CREDITS STATIC
  2.  
  3. REM PUTS UP CREDITS WHEN PROGRAM INVOKED
  4.  
  5. DEFINT A-Z
  6. SEC = 3
  7. CLS
  8. KEY OFF
  9.  
  10. RO=01:CO=12:X$="BLED - A SOURCE CODE MERGE UTILITY  ver 1.3  April 12, 1986"
  11. CALL QPRINT (X$,RO,CO)
  12. RO=03:CO=03:X$="Copyright (c) 1985-86  Ken Goosens, 5020 Portsmouth Rd, Fairfax, VA 22032"
  13. CALL QPRINT (X$,RO,CO)
  14. RO=06:CO=02:X$="You are granted a limited license to use and distribute this program provided"
  15. CALL QPRINT (X$,RO,CO)
  16. RO=08:CO=10:X$="1.  you do not alter or remove this notice"
  17. CALL QPRINT (X$,RO,CO)
  18. RO=10:CO=10:X$="2.  you receive no fee or charge for this program"
  19. CALL QPRINT (X$,RO,CO)
  20. RO=12:CO=10:X$="3.  modifications are distributed only as a merge to this program"
  21. CALL QPRINT (X$,RO,CO)
  22. RO=14:CO=10:X$="4.  you assume all liability for using this program"
  23. CALL QPRINT (X$,RO,CO)
  24. LOCATE 16,1:CALL PRTHELP
  25. CALL WAITSECORKEY (SEC)
  26.  
  27. END SUB
  28.  
  29. SUB PRTHELP STATIC
  30.  
  31. REM PRINTS HELP (DOCUMENTATION) SCREEN
  32.  
  33. PRINT
  34. PRINT "    To apply  a merge:  BLED[/B/L/M]  {source} {merges} {new file}"
  35. PRINT "    To create a merge:  BLED[/F/B]  {old version} {new version} {merges}"
  36. PRINT "All arguments optional: B=run batch  F=file compare  L=line# merge  M=merge"
  37. PRINT
  38.  
  39. END SUB
  40. SUB GETNXTCMD (CMD$,DOCCHAR$,STBLKTYPE$,ENDBLKTYPE$,STDES.NO%,ENDDES.NO%,_
  41.                STTARGET$,ENDTARGET$,INCREMENT%,PTR%,CMD.TYPE$,_
  42.                INS.BLKTYPE$,FIXED.NO%,BLK.DISP$) STATIC
  43.  
  44. REM FETCHES NEXT COMMAND, PARSES, AND SETS ALL PARMS FOR PROCESSING
  45.  
  46. DEFINT A-Z
  47. DIM BUF$(10)
  48. REM PRINT "GETNXTCMD ENTERED"
  49. CALL READNXT (BUF$(),NUM.NBUF%,DOCCHAR$,CMD$)
  50.  
  51. IF CMD$ = "" THEN_
  52.    CMD.TYPE$ = ""_
  53. ELSE_
  54.    CALL PARSECMD (CMD$,STBLKTYPE$,ENDBLKTYPE$,STDES.NO%,ENDDES.NO%,_
  55.                STTARGET$,ENDTARGET$,INCREMENT%,PTR%,INCLUSIVE%,CMD.TYPE$,_
  56.                INS.BLKTYPE$,FIXED.NO%):_
  57.    IF CMD.TYPE$ = "B" THEN_
  58.       CALL GETDISP (BUF$(),NUM.NBUF%,DOCCHAR$,BLK.DISP$):_
  59.       IF INCLUSIVE% THEN_
  60.         NUM.NBUF% = NUM.NBUF%+1:_
  61.         BUF$(NUM.NBUF%) = BLK.DISP$:_
  62.         NUM.NBUF% = NUM.NBUF%+1:_
  63.         BUF$(NUM.NBUF%)="BLOCK FROM LINE * TO *+1"
  64.  
  65. REM PRINT "GETNXTCMD: CMD=";CMD$;" CMD TYPE=";CMD.TYPE$;" BLOCK DISP=";BLK.DISP$
  66. END SUB
  67.  
  68. SUB GETDISP (BUF$(1),NUM.NBUF%,DOCCHAR$,BLK.DISP$) STATIC
  69.  
  70. REM PASS BUF$      - ARRAY CONTAINING BUFFERED BLED COMMANDS
  71. REM      NUM.NBUF%  - NUMBER OF UNUSED ELEMENTS IN BUF$
  72. REM      DOCCHAR$   - FIRST CHAR OF REMARK LINE IN MERGE FILE (1ST WORD)
  73. REM GET  BLK.DISP$  - DISPOSITION OF BLOCK
  74.  
  75. DEFINT A-Z
  76. REM PRINT "GETDISP ENTERED NUM.NBUF=";NUM.NBUF%
  77. ONE = 1
  78.   CALL READNXT (BUF$(),NUM.NBUF%,DOCCHAR$,CMD$)
  79.   CALL FIRSTNB (CMD$,ONE,BS)
  80.   IF BS>0 THEN BLK.DISP$ = MID$(CMD$,BS,1) ELSE BLK.DISP$ = "K"
  81.   IF INSTR("DRK",BLK.DISP$) = 0 THEN_
  82.      BLK.DISP$="K":_
  83.      NUM.NBUF% = NUM.NBUF%+1:_
  84.      BUF$(NUM.NBUF%) = CMD$_
  85.   ELSE_
  86.      IF BLK.DISP$ = "R" THEN_
  87.         BLK.DISP$ = "D":_
  88.         NUM.NBUF% = NUM.NBUF%+1:_
  89.         CALL LASTNB (CMD$,BS,ES):_
  90.         IF ES < LEN(CMD$) THEN_
  91.            BUF$(NUM.NBUF%) = "I "+MID$(CMD$,ES+1)_
  92.         ELSE_
  93.            N$="REPLACE command must be followed by 'BLOCK' or # of lines":_
  94.            CALL WRMIS (CMD$,N$)
  95.            
  96. END SUB
  97.  
  98. SUB READNXT (BUF$(1),NUM.NBUF%,DOCCHAR$,CMD$) STATIC
  99.  
  100. REM PROCESSES REQUEST FOR NEXT BLED COMMAND
  101. REM PASS BUF$     - BUFFER ARRAY
  102. REM      NUM.NBUF% - NUMBER ACTIVE ENTRIES IN BUFFER
  103. REM      DOCCHAR$  - FIRST CHAR OF DOCUMENTATION LINE
  104. REM GET  CMD$     - BLED COMMAND LINE 
  105.  
  106. DEFINT A-Z
  107. ONE = 1
  108. CMD$=""
  109. FW$=""
  110. IF NUM.NBUF% > 0 THEN_
  111.    CMD$ = BUF$(NUM.NBUF%):_
  112.    NUM.NBUF% = NUM.NBUF%-1:_
  113.    GOTO GETOUTREADNXT
  114.  
  115. WHILE (CMD$=SPACE$(LEN(CMD$)) OR LEFT$(FW$,1)=DOCCHAR$) AND NOT EOF(2)
  116.    CALL GETTRANS (CMD$,ONE)
  117.    CALL FIRSTWORD (CMD$,FW$)
  118. WEND
  119. IF EOF(2) AND LEFT$(FW$,1)=DOCCHAR$ THEN_
  120.    CMD$=""
  121. IF CMD$=SPACE$(LEN(CMD$)) THEN_
  122.    IF EOF(1) THEN_
  123.       CMD$=""_
  124.    ELSE_
  125.       CMD$ = "BLOCK FROM LINE * THRU END":_
  126.       NUM.NBUF% = NUM.NBUF%+1:_
  127.       BUF$(NUM.NBUF%)="KEEP"
  128.  
  129. GETOUTREADNXT:
  130. REM PRINT "FROM READNXT: CMD IS {";CMD$;"}  DOCCHAR=";DOCCHAR$
  131. END SUB
  132.  
  133. SUB PRTSCRN (NUMFLDS%,ROW%(1),COL%(1),PROMPT$(1),FLDSIZE%(1),_
  134.                 FLDTYPE$(1),FLDVAL$(1),HLP$(1)) STATIC
  135.  
  136. REM PRINTS TABLE DRIVEN SCREEN
  137.  
  138. DEFINT A-Z
  139. CLS
  140. FOR I=1 TO NUMFLDS%
  141.   CALL QPRINT (PROMPT$(I),ROW%(I),COL%(I))
  142.   X% = COL%(I)+LEN(PROMPT$(I))+1
  143.   CALL ECHO (FLDVAL$(I),ROW%(I),X%,FLDSIZE%(I))
  144. NEXT I
  145.  
  146. END SUB
  147.  
  148. SUB GETSCRN (NUMFLDS%,ROW%(1),COL%(1),PROMPT$(1),FLDSIZE%(1),_
  149.                 FLDTYPE$(1),FLDVAL$(1),HLP$(1)) STATIC
  150.  
  151. REM DOES FULL SCREEN DATA ENTRY FOR TABLE DRIVEN SCREEN
  152.  
  153. DEFINT A-Z
  154. NUL$ = ""
  155. TOPGETSCRN:
  156.   FOR I=1 TO NUMFLDS%
  157.     CALL EXPLAIN (HLP$(I))
  158.     X = INSTR("LSN",FLDTYPE$(I))
  159.     IF X > 1 THEN_
  160.       IF X = 2 THEN_
  161.          CALL GETSTR (ROW%(I),COL%(I),PROMPT$(I),FLDSIZE%(I),FLDVAL$(I))_
  162.       ELSE_
  163.          CALL GETNATNUM (ROW%(I),COL%(I),PROMPT$(I),FLDSIZE%(I),FLDVAL$(I))
  164.   NEXT I
  165.  
  166. END SUB
  167.  
  168. SUB PARSECMD (CMD$,STBLKTYPE$,ENDBLKTYPE$,STDES.NO%,ENDDES.NO%,_
  169.                STTARGET$,ENDTARGET$,INCREMENT%,PTR%,INCLUSIVE%,CMD.TYPE$,_
  170.                INS.BLKTYPE$,FIXED.NO%) STATIC
  171.  
  172. DEFINT A-Z
  173. DIM WRDS$(10)
  174. REM BREAKS COMMAND LINE INTO WORDS AND CHECKS FOR PROPER SYNTAX
  175.  
  176. REM PASS CMD$     - BLED COMMAND LINE
  177. REM      PTR%     - CURRENT LINE POSITION IN ORIGINAL SOURCE FILE
  178. REM GET  STBLKTYPE$  - BLOCK TYPE DEFINING START BLOCK
  179. REM     ENDBLKTYPE#  - BLOCK TYPE DEFINING END BLOCK
  180. REM      STDES.NO%   - LINE NUMBER OF SOURCE THAT BEGINS BLOCK
  181. REM     ENDDES.NO%   - LINE NUMBER OF SOURCE THAT ENDS BLOCK
  182. REM      STTARGET$   - STRING/LABEL DEFINING START OF BLOCK
  183. REM     ENDTARGET$   - STRING/LABEL DEFINING END OF BLOCK
  184. REM     INCREMENT%   - COUNTER FOR ADVANCING READS (0 IF TO END,
  185. REM                       NORMALLY AND OTHERWISE 1)
  186. REM     CMD.TYPE$    - TYPE OF COMMAND (Insert, Block)
  187. REM     INS.BLKTYPE$ - TYPE OF INSERT BLOCK (Blocked, or Lines)
  188. REM     FIXED.NO%    - Fixed number of lines to insert
  189.  
  190. CALL BRKWORDS(CMD$,WRDS$())
  191.  
  192. CMD.TYPE$ = LEFT$(WRDS$(1),1)
  193. IF INSTR("IB",CMD.TYPE$) = 0 THEN_
  194.    EXP$ = "BLED COMMAND MUST BEGIN WITH 'I' OR 'B'":_
  195.    CALL WRMIS(EXP$,CMD$):_
  196.    GOTO GETOUT:
  197. IF CMD.TYPE$ = "I" AND WRDS$(2)="" THEN WRDS$(2)="B"
  198. IF CMD.TYPE$ = "I" THEN_
  199.    IF LEFT$(WRDS$(2),1) <> "B" THEN_
  200.       INS.BLKTYPE$="L":_
  201.       CALL NUMERIC(WRDS$(2),POSNUM):_
  202.       IF POSNUM THEN_
  203.          FIXED.NO% = VAL(WRDS$(2)):GOTO GETOUT:_
  204.       ELSE_
  205.          EXP$ = "INSERT command should specify # of lines to include":_
  206.          CALL WRMIS(EXP$,CMD$):GOTO GETOUT:_
  207.    ELSE_
  208.       INS.BLKTYPE$="B":_
  209.       GOTO GETOUT:
  210.   
  211. IF LEFT$(WRDS$(2),1) = "F" THEN_
  212.    NXT.WRD = 3 _
  213. ELSE_
  214.    NXT.WRD = 2
  215. CALL CHKWRDS (STBLKTYPE$,STDES.NO%,STTARGET$,NXT.WRD,INCREMENT%,WRDS$(),_
  216.               NXT.WRD,PTR%)
  217. NXT.WRD = NXT.WRD + 1
  218. FL$ = LEFT$(WRDS$(NXT.WRD),1)
  219. IF INSTR("UT",FL$) = 0 THEN_
  220.    INCLUSIVE%=0 _
  221. ELSE_
  222.    NXT.WRD = NXT.WRD+1:_
  223.    IF FL$="U" OR WRDS$(NXT.WRD-1)="TO" THEN_
  224.       INCLUSIVE% = 0_
  225.    ELSE_
  226.       INCLUSIVE% = -1
  227. CALL CHKWRDS (ENDBLKTYPE$,ENDDES.NO%,ENDTARGET$,NXT.WRD,INCREMENT%,WRDS$(),_
  228.               NXT.WRD,PTR%)
  229. GETOUT:
  230. REM PRINT "PARSECMD: INCLUSIVE=";INCLUSIVE%
  231. END SUB
  232.  
  233. SUB CHKWRDS(BLKTYPE$,DES.NO%,TARGET$,NUWRD%,INCMT%,WRDS$(1),BEG%,PTR%) STATIC
  234.  
  235. DEFINT A-Z
  236. REM PASS WRDS$      - ARRAY OF WORDS
  237. REM      BEG%        - FIRST ELEMENT OF ARRAY TO EXAMINE
  238. REM      PTR%        - CURRENT LINE # OF SOURCE FILE
  239. REM GET  BLKTYPE$  - HOW BLOCK DEFINED (LINE,STRING,LABEL)
  240. REM      DES.NO%     - DESIRED LINE NUMBER FOR LINE BLOCK TYPE
  241. REM      TARGET$    - TARGET STRING FOR STRING/LABEL BLOCK TYPE
  242. REM      INCMT%      - FLAG SET TO 0 WHEN BLOCK EXTENDS TO END-OF-FILE,
  243. REM                     OTHERWISE 1
  244. REM      NUWRD%      - LAST WORD POSITION THIS ROUTINE EXAMINED
  245. REM PRINT "SUB CHKWRDS RECEIVED BEG=";BEG%;" PTR=";PTR%
  246. TARGET$=""
  247. INCMT%=1
  248. DES.NO%=0
  249. IF BEG%<1 THEN BEG%=1:PRINT "UPPED BEG%"
  250. REM IF PTR%<10 THEN PTR%=10:PRINT "UPPED PTR%"
  251. WD$ = WRDS$(BEG%)
  252. FLET$ = LEFT$(WD$,1)
  253. IF FLET$ <> "L" AND FLET$ <> "S" THEN_
  254.    BLKTYPE$ = "L":_
  255.    NUWRD% = BEG%_
  256. ELSE_
  257.    NUWRD% = BEG%+1:_
  258.    IF WD$ = "LABEL" OR WD$="LABEL#" THEN_
  259.      BLKTYPE$ = "LABEL":_
  260.      TARGET$ = WRDS$(NUWRD%)_
  261.    ELSE IF FLET$ = "S" THEN_
  262.      BLKTYPE$ = "S":_
  263.      TARGET$ = WRDS$(NUWRD%)_
  264.    ELSE_
  265.      BLKTYPE$ = "L"
  266. WD$ = WRDS$(NUWRD%)
  267. L2$ = LEFT$(WD$,2)
  268. RES$ = MID$(WD$,3)
  269. IF BLKTYPE$ = "L" THEN_
  270.   IF L2$ = "*+" THEN_
  271.       CALL NUMERIC (RES$,POSNUM):_
  272.       IF POSNUM THEN_
  273.          DES.NO% = VAL(RES$)+PTR%_
  274.       ELSE_
  275.          M$="NON-NUMERIC IN LINE NUMBER FIELD":_
  276.          CALL WRMIS(M$,WD$)_
  277.   ELSE_
  278.       IF L2$ = "*" THEN_
  279.         DES.NO% = PTR%_
  280.       ELSE_
  281.         CALL NUMERIC(WD$,POSNUM):_
  282.         IF POSNUM THEN_
  283.            DES.NO% = VAL(WD$)_
  284.         ELSE IF WD$ = "END" THEN_
  285.                INCMT% = 0_
  286.              ELSE_
  287.                M$="NON-NUMERIC IN LINE NUMBER FIELD":_
  288.                CALL WRMIS(M$,WD$)
  289. IF BLKTYPE$ <> "L" AND TARGET$ = "" THEN_
  290.     M$ = "STRING/LABEL MISSING":_
  291.     CALL WRMIS(M$,WD$)
  292. REM PRINT "CHKWRDS RETURNED DESNO=";DES.NO%;" NUWRD=";NUWRD%
  293. END SUB
  294.  
  295. SUB GETSTR (ROW%,COL%,PROMPT$,FLDSIZE%,RESULT$) STATIC
  296.  
  297. REM INPUT ROUTINE TO GET A STRING
  298. REM LOCATE 24,70:PRINT "GETSTR  ";
  299.  
  300. X% = FLDSIZE%+1:IF X%<8 THEN X%=8
  301. CALL QPRINT (PROMPT$+SPACE$(X%),ROW%,COL%)
  302. X% = COL% + LEN(PROMPT$) + 1
  303. CALL ECHO (RESULT$,ROW%,X%,FLDSIZE%)
  304. LOCATE ROW%,X%
  305. INPUT "",X$
  306. IF X$ <> "" THEN RESULT$ = X$:CALL ECHO (RESULT$,ROW%,X%,FLDSIZE%)
  307.  
  308. END SUB
  309.  
  310. SUB GETCHAR (ROW%,COL%,PROMPT$,VLDANS$,RESULT$) STATIC
  311.  
  312. REM ROUTINE TO GET SINGLE CHARACTER
  313. REM LOCATE 24,70:PRINT "GETCHAR ";
  314. DEFINT A-Z
  315. CR$ = CHR$(13)
  316. FLDSIZE% = 1
  317. CALL QPRINT (PROMPT$+RESULT$,ROW%,COL%)
  318. X% = COL% + LEN(PROMPT$)
  319. LOCATE ROW%,X%,1,6,7
  320. X$ = INPUT$(1)
  321. IF X$ = CR$ THEN X$ = RESULT$:IF X$="" THEN X$=CHR$(0)
  322. CALL UPCASE (X$)
  323. IF VLDANS$ <> "" THEN_
  324.     WHILE INSTR(VLDANS$,X$)=0:_
  325.       BEEP:_
  326.       X$ = INPUT$(1):CALL UPCASE (X$):_
  327.     WEND
  328. RESULT$ = X$:PRINT RESULT$;
  329.  
  330. END SUB
  331.  
  332. SUB GETNATNUM (ROW%,COL%,PROMPT$,FLDSIZE%,RESULT$) STATIC
  333.  
  334. REM ROUTINE TO INPUT ONLY NATURAL NUMBER (> OR = 0)
  335. REM LOCATE 24,70:PRINT "GETNATNUM ";
  336.  
  337. DEFINT A-Z
  338. RESTART:
  339.   CALL GETSTR (ROW%,COL%,PROMPT$,FLDSIZE%,RESULT$)
  340.   CALL NUMERIC (RESULT$,NONNEG%)
  341. IF NOT NONNEG% THEN BEEP:GOTO RESTART
  342.  
  343. END SUB
  344.  
  345. SUB ECHO (STRNG$,ROW%,COL%,FLDSIZE%) STATIC
  346.  
  347. REM ROUTINE FOR CLEARING A SPACE AND PRINTING MESSAGE
  348.  
  349. CALL QPRINT (SPACE$(FLDSIZE%),ROW%,COL%)
  350. CALL QPRINT (STRNG$,ROW%,COL%)
  351.  
  352. END SUB
  353.  
  354. SUB TRIM (STRNG$) STATIC
  355.  
  356. REM REMOVES LEADING AND TRAILING BLANKS FROM STRNG$
  357.  
  358. DEFINT A-Z
  359. ONE = 1
  360. CALL FIRSTNB (STRNG$,ONE,STRT)
  361. IF STRT < 1 THEN_
  362.    STRT = 1:LST = 0_
  363. ELSE_
  364.    CALL ENDNB (STRNG$,LST)
  365. STRNG$ = MID$(STRNG$,STRT,LST-STRT+1)
  366.  
  367. END SUB
  368.  
  369. SUB ENDNB (STRNG$,LST%) STATIC
  370.  
  371. REM LOCATES LAST NON-BLANK CHARACTER IN STRNG$.  0 IF NONE.
  372.  
  373. REM PASS STRNG$ - STRING TO BE SEARCHED
  374. REM GET  LST%   - POSITION IN STRNG$ OF LAST NON-BLANK
  375.  
  376.    X$ = "!"+STRNG$
  377.    LST% = LEN(X$)
  378.    WHILE MID$(X$,LST%,1)=" "
  379.      LST% = LST%-1
  380.    WEND
  381.    LST% = LST% - 1
  382.  
  383. END SUB
  384.  
  385. SUB BRKWORDS (STRNG$,WORDS$(1)) STATIC
  386.  
  387. REM PASS STRNG$  - A STRING TO BE BROKEN INTO WORDS (SPACE
  388. REM                 DELIMITED STRINGS)
  389. REM      WORDS$  - AN ARRAY TO PUT WORDS IN
  390.  
  391. DEFINT A-Z
  392. ONE = 1
  393. LST = LEN(STRNG$)
  394. X$ = STRNG$ + " !"
  395. CALL FIRSTNB(X$,ONE,BS)
  396. NPARMS = 0
  397. MAXPARMS = UBOUND(WORDS$)
  398. WHILE BS <= LST
  399.   NPARMS = NPARMS + 1
  400.   CALL LASTNB (X$,BS,ES)
  401.   IF NPARMS > MAXPARMS THEN _
  402.      BS = LST+1_
  403.   ELSE_
  404.      WORDS$(NPARMS) = MID$(X$,BS,ES-BS+1):_
  405.      BS = ES+1:_
  406.      CALL FIRSTNB(X$,BS,BS)
  407. WEND
  408. END SUB
  409.  
  410. SUB FIRSTWORD (STRNG$,FIRST.WORD$) STATIC
  411.  
  412. REM RETURNS FIRST WORD IN STRNG$
  413. REM PASS STRNG$   - STRING TO BE SEARCHED
  414. REM GET  FIRST.WORD$ - FIRST WORD IN STRNG$
  415.  
  416. DEFINT A-Z
  417.  
  418. ONE = 1
  419. CALL FIRSTNB (STRNG$,ONE,BS)
  420. IF BS > 0 THEN_
  421.    CALL LASTNB (STRNG$,BS,ES):_
  422.    FIRST.WORD$ = MID$(STRNG$,BS, ES-BS+1)_
  423. ELSE_
  424.    FIRST.WORD$ = ""
  425.  
  426. END SUB
  427.  
  428. SUB FIRSTNB (STRNG$,BEG%,WHEREIS%) STATIC
  429.  
  430. REM PASS STRNG$  - A STRING TO BE SEARCHED
  431. REM      BEG%     - POSITION TO BEGIN SEARCH
  432. REM GET  WHEREIS% - POSITION IN STRNG$ OF FIRST NON-BLANK AT
  433. REM                  BEG% OR LATER.  RETURNS 0 IF NO NON-BLANK.
  434.  
  435. DEFINT A-Z
  436. REM LOCATE 24,70:PRINT "FIRSTNB  ";
  437. X$ = STRNG$+"!"
  438. WHEREIS% = BEG%
  439. IF WHEREIS% < 1 THEN WHEREIS% = 1
  440. WHILE MID$(X$,WHEREIS%,1) = " "
  441.    WHEREIS% = WHEREIS% + 1
  442. WEND
  443. IF WHEREIS% > LEN(STRNG$) THEN WHEREIS% = 0
  444.  
  445. END SUB
  446.  
  447. SUB LASTNB (STRNG$,BEG%,WHEREIS%) STATIC
  448.  
  449. REM PASS STRNG$   - A STRING TO BE SEARCHED
  450. REM      BEG%      - POSITION TO BEGIN SEARCH
  451. REM GET  WHEREIS%  - LAST POSITION IN STRNG$ OF ANY WORD BEGINNING AT
  452. REM                   BEG% OR LATER.  RETURNS BEG%-1 IF NO WORD AT BEG%.
  453.  
  454. DEFINT A-Z
  455. REM LOCATE 24,70:PRINT "LASTNB  ";
  456. B = BEG
  457. IF B < 1 THEN B = 1
  458. IF B > LEN(STRNG$) THEN_
  459.    X$ = " " _
  460. ELSE_
  461.    X$ = MID$(STRNG$,B)+" "
  462. WHEREIS% = INSTR(X$," ") - 1 + B - 1
  463.  
  464. END SUB
  465.  
  466. SUB REALNUM (STRNG$,RESULT%) STATIC
  467.  
  468. REM CHECKS WHETHER STRNG$ IS A VALID REAL NUMBER
  469. REM PASS STRNG$  - STRING TO BE CHECKED
  470. REM GET  RESULT% - TRUE IF REAL
  471.  
  472. DEFINT A-Z
  473. X$ = STRNG$+"."
  474. LENGTH = LEN(STRNG$)
  475. J=1
  476. WHILE INSTR("+- ",MID$(X$,J,1))
  477.   J=J+1
  478. WEND
  479. IF J > LENGTH THEN RESULT% = 0:EXIT SUB
  480.  
  481. X = INSTR(X$,".")
  482. FRONT$ = MID$(STRNG$,J,X-J)
  483. IF X > LENGTH THEN_
  484.    BACK$=""_
  485. ELSE_
  486.    BACK$  = MID$(STRNG$,X+1)
  487.  
  488. CALL NUMERIC (FRONT$,FRNNAT%)
  489. CALL NUMERIC (BACK$,BNNAT%)
  490. RESULT% = (FRNNAT% AND BNNAT%)
  491.  
  492. END SUB
  493.  
  494. SUB NUMERIC (STRNG$,RESULT%) STATIC
  495.  
  496. REM PASS STRNG$  - A STRING TO BE SEARCHED
  497. REM GET  RESULT%  - TRUE IF STRNG$ CONTAINS ONLY NON-NEGATIVE DIGITS 
  498. REM                  OR LEADING OR TRAILING BLANKS
  499.  
  500. DEFINT A-Z
  501. IF STRNG$=SPACE$(LEN(STRNG$)) THEN RESULT%=0:GOTO GETOUTNUMERIC
  502. NUM$="0123456789"
  503. CALL NOOTHER (STRNG$,NUM$,RESULT%)
  504. GETOUTNUMERIC:
  505. END SUB
  506.  
  507. SUB NOOTHER (STRNG$,ONLY$,RESULT%) STATIC
  508.  
  509. REM PASS STRNG$  - A STRING TO BE SEARCHED
  510. REM      ONLY$   - A LIST OF THE ONLY CHARACTERS TO BE IN STRNG$
  511. REM GET  RESULT%  - TRUE OF ONLY CHARACTERS IN STRNG$ ARE THOSE IN ONLY$
  512. REM                   OR ARE LEADING OR TRAILING BLANKS
  513.  
  514. DEFINT A-Z
  515.  
  516. RESULT% = -1
  517. IF LEN(STRNG$) < 1 THEN GOTO GETOUTNOOTHER
  518. ONE = 1
  519. CALL FIRSTNB(STRNG$,ONE,BS)
  520. CALL LASTNB(STRNG$,BS,ES)
  521.  
  522. FOR I=BS TO ES
  523.    IF INSTR(ONLY$,MID$(STRNG$,I,1)) = 0 THEN_
  524.       RESULT% = 0:_
  525.       I=ES+1
  526. NEXT I
  527.  
  528. IF STRNG$ <> MID$(STRNG$,1,ES)+SPACE$(LEN(STRNG$)-ES) THEN RESULT% = 0
  529.  
  530. GETOUTNOOTHER:
  531. END SUB
  532.  
  533. SUB REMOVE (L$,BADSTRNG$) STATIC
  534.  
  535. REM REMOVES FROM L$ ALL INSTANCES OF CHARACTERS IN BADSTRNG$
  536.  
  537. REM PASS L$        - STRING TO BE ALTERED
  538. REM      BADSTRNG$ - LIST OF CHARACTERS TO REMOVE
  539. REM GET  L$        - ORIGINAL MINUS BADSTRNG$
  540.  
  541. DEFINT A-Z
  542. J = 0
  543. FOR I=1 TO LEN(L$)
  544.   IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN_
  545.      J = J+1:_
  546.      MID$(L$,J,1) = MID$(L$,I,1)
  547. NEXT I
  548. L$ = LEFT$(L$,J)
  549.  
  550. END SUB
  551.  
  552. SUB KEEPONLY (L$,GOODSTRNG$) STATIC
  553.  
  554. REM KEEPS IN L$ ONLY THOSE CHARACTERS IN GOODSTRNG$, I.E.
  555. REM     REMOVES FROM L$ ALL INSTANCES OF CHARACTERS NOT IN GOODSTRNG$
  556.  
  557. REM PASS L$         - STRING TO BE ALTERED
  558. REM      GOODSTRNG$ - LIST OF CHARACTERS TO KEEP
  559. REM GET  L$         - ORIGINAL MINUS CHARS NOT IN GOODSTRNG$
  560.  
  561. DEFINT A-Z
  562. J = 0
  563. FOR I=1 TO LEN(L$)
  564.   IF INSTR(GOODSTRNG$,MID$(L$,I,1)) THEN_
  565.      J = J+1:_
  566.      MID$(L$,J,1) = MID$(L$,I,1)
  567. NEXT I
  568. L$ = LEFT$(L$,J)
  569.  
  570. END SUB
  571.  
  572. SUB TRANSLATE (L$,GOT$,WANT$) STATIC
  573.  
  574. REM REPLACES IN L$ ALL INSTANCES OF CHARACTER IN GOT$ BY CORRESPONDING
  575. REM   CHARACTER IN WANT$
  576.  
  577. REM PASS L$     - STRING TO BE ALTERED
  578. REM      GOT$   - LIST OF CHARACTERS WANTED REPLACED
  579. REM      WANT$  - WHAT REPLACE BY
  580. REM GET  L$     - ALTERED STRING
  581.  
  582. DEFINT A-Z
  583. FOR I=1 TO LEN(L$)
  584.   PO = INSTR(GOT$,MID$(L$,I,1))
  585.   IF PO THEN MID$(L$,I,1) = MID$(WANT$,PO,1)
  586. NEXT I
  587.  
  588. END SUB
  589.  
  590. SUB EXPERR (STRNG$) STATIC
  591.  
  592. REM EXPLAIN AN ERROR
  593.  
  594. DEFINT A-Z
  595. BEEP
  596.  
  597. CALL EXPLAIN (STRNG$)
  598. SEC = 2
  599. CALL WAITSECORKEY (SEC)
  600. BEEP
  601.  
  602. END SUB
  603.  
  604. SUB EXPLAIN (STRNG$) STATIC
  605.  
  606. REM CONTROLS MESSAGE IN INVERSE VIDEO ON LINE 24
  607.  
  608. DEFINT A-Z
  609. RO = 24
  610. CO = 3
  611. PGE = 0
  612. ATTR = (7 AND 7)*16
  613. X$ = LEFT$(STRNG$,75)
  614. CALL XQPRINT (" "+X$+SPACE$(75-LEN(X$)),RO,CO,ATTR,PGE)
  615. COLOR 7,0
  616.  
  617. END SUB
  618.  
  619. SUB WAITSECORKEY (SECONDS%) STATIC
  620.  
  621. REM PAUSE ROUTINE BASED ON CLOCK
  622. REM SEND SECONDS% - MAXIMUM # SECONDS TO WAIT
  623. REM WILL QUIT IF ANY KEY PRESSED
  624.  
  625. CURSEC! = (val(mid$(time$,4,2))*60+val(mid$(time$,7,2)))
  626. DONE!   = CURSEC! + SECONDS%
  627. WHILE CURSEC! < DONE! AND INKEY$ = ""
  628.    CURSEC! = (val(mid$(time$,4,2))*60+val(mid$(time$,7,2)))
  629. WEND
  630.  
  631. END SUB
  632.  
  633. SUB WRMIS (EXPLAIN$,MISTAKE$) STATIC
  634.  
  635. REM PASS EXPLAIN$  - ERROR MESSAGE
  636. REM      MISTAKE#  - THE MISTAKE CAUSING THE ERROR
  637. REM      WARNFILE$ - FILE TO WRITE MESSAGES TO
  638. REM GET            - LOG MISTAKE & EXPLANATION TO FILE F$
  639.  
  640. DEFINT A-Z
  641.  
  642. PRINT #4,MISTAKE$
  643. PRINT #4,EXPLAIN$
  644. NWARN = NWARN + 1
  645. LOCATE 24,69:PRINT NWARN;
  646.  
  647. END SUB
  648.  
  649. SUB GETTRANS (TRANS$,NTRANS%) STATIC
  650.  
  651. REM FETCHES TRANSACTION RECORD
  652. REM PASS NTRANS% - VALUE OF 0 TO INITIALIZE COUNTER, OTHERWISE > 0
  653. REM GET  TRANS%  - NEW TRANSACTION RECORD
  654.  
  655.    DEFINT A-Z
  656.  
  657.    LINE INPUT #2,TRANS$
  658.    IF NTRANS% < 1 THEN LOCTRANS = 0:NTRANS% = 1
  659.    LOCTRANS = LOCTRANS% + 1
  660.    LOCATE 24,31:PRINT LOCTRANS%;
  661.  
  662. END SUB
  663.  
  664. SUB CENTERBEG (STRNG$,LSIZE%,BEG%) STATIC
  665.  
  666. REM COMPUTERS CENTERED POSITION OF STRNG$ IN FIELD OF SIZE LSIZE%
  667. REM PASS STRNG$   - STRING TO BE CENTERED
  668. REM      LSIZE%   - LENGTH OF FIELD TO CENTER
  669. REM GET  BEG%     - STARTING POSITION OF STRNG$ IN LSIZE%.  RETURNS
  670. REM                 1 IF STRNG$ TOO BIG TO FIT
  671.  
  672.    DEFINT A-Z
  673.    X = LEN(STRNG$)
  674.    IF X > LSIZE% THEN_
  675.      BEG% = 1_
  676.    ELSE_
  677.      BEG% = (LSIZE% - X)/2
  678.  
  679. END SUB
  680.